home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TOOLPAS2 / MDOSIO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-09-10  |  15KB  |  583 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * mdosio - library for interface to DOS v3 file access functions (3-1-89)
  15.  *
  16.  *)
  17.  
  18. {$i prodef.inc}
  19. {$undef DEBUGGING}
  20.  
  21. unit MDosIO;
  22.  
  23. interface
  24.  
  25.    uses Dos,debugs;
  26.  
  27.    type
  28.       dos_filename = string[64];
  29.       dos_handle   = word;
  30.  
  31.       long_integer = record
  32.          lsw: word;
  33.          msw: word;
  34.       end;
  35.  
  36.       seek_modes = (seek_start {0},
  37.                     seek_cur   {1},
  38.                     seek_end   {2});
  39.  
  40.       open_modes = (open_read  {h40},     {deny_nothing, allow_read}
  41.                     open_write {h41},     {deny_nothing, allow_write}
  42.                     open_update{h42});    {deny_nothing, allow_read+write}
  43.  
  44.       dos_time_functions = (time_get,
  45.                             time_set);
  46.  
  47.    const
  48.       dos_error   = $FFFF; {file handle after an error}
  49.       min_handle  = 2;
  50.       max_handle  = 10;
  51.       dos_retry_count:  integer = 0;
  52.  
  53.    var
  54.       dos_regs:         registers;
  55.       dos_name:         dos_filename;
  56.       dos_write_err:    boolean;
  57.       dos_names:        array[min_handle..max_handle] of dos_filename;
  58.  
  59.    type
  60.       dos_functions = (_open,  _creat,
  61.                        _close, _times,
  62.                        _read,  _write,
  63.                        _rseek, _lseek,
  64.                        _lock,  _unlock);
  65.  
  66.    const
  67.       function_names:  array[dos_functions] of string[5] =
  68.                       ('OPEN', 'CREAT',
  69.                        'CLOSE','TIMES',
  70.                        'READ', 'WRITE',
  71.                        'RSEEK','LSEEK',
  72.                        'LOCK', 'UNLCK');
  73.                        
  74.  
  75.    procedure dos_check_error(fun: dos_functions);
  76.  
  77.    procedure dos_call(fun: dos_functions);
  78.  
  79.    function dos_open(name:      dos_filename;
  80.                      mode:      open_modes):  dos_handle;
  81.  
  82.    function dos_create(name:    dos_filename): dos_handle;
  83.  
  84.    function dos_read( handle:   dos_handle;
  85.                       var       buffer;
  86.                       bytes:    word): word;
  87.  
  88.    procedure dos_write(handle:  dos_handle;
  89.                        var      buffer;
  90.                        bytes:   word);
  91.  
  92.    procedure dos_lseek(handle:  dos_handle;
  93.                        offset:  longint;
  94.                        method:  seek_modes);
  95.  
  96.    procedure dos_rseek(handle:  dos_handle;
  97.                        recnum:  word;
  98.                        recsiz:  word;
  99.                        method:  seek_modes);
  100.  
  101.    function dos_tell: longint;
  102.  
  103.    procedure dos_find_eof(fd:   dos_handle);
  104.  
  105.    procedure dos_close(handle:  dos_handle);
  106.  
  107.    procedure dos_unlink(name:   dos_filename);
  108.  
  109.    procedure dos_file_times(fd:       dos_handle;
  110.                             func:     dos_time_functions;
  111.                             var time: word;
  112.                             var date: word);
  113.  
  114.    function dos_jdate(time,date: word): longint;
  115.  
  116.    function dos_exists(name: dos_filename): boolean;
  117.  
  118.    function dos_lock(handle:  dos_handle;
  119.                      offset:  longint;
  120.                      bytes:   word): boolean;
  121.  
  122.    procedure dos_unlock(handle:  dos_handle;
  123.                         offset:  longint;
  124.                         bytes:   word);
  125.  
  126.    procedure dos_time(var ms: longint);
  127.  
  128.    procedure dos_delay(ms: longint);
  129.  
  130.  
  131. implementation
  132.  
  133. (* -------------------------------------------------------- *)
  134. procedure dos_check_error(fun: dos_functions);
  135. var
  136.    msg:  string[40];
  137. begin
  138.    dos_regs.es := dos_regs.ax;   {save possible error code}
  139.  
  140.    if (dos_regs.flags and Fcarry) <> 0 then
  141.    begin
  142.       case dos_regs.ax of
  143.          2:   msg := 'FILE NOT FOUND';
  144.          3:   msg := 'DIR NOT FOUND';
  145.         {4:   msg := 'TOO MANY OPEN FILES';}
  146.          5:   msg := 'ACCESS DENIED';
  147.          else str(dos_regs.ax,msg);
  148.       end;
  149. {$I-}
  150.       writeln(debugfd^,' DOS error ['+msg+'] on file ['+dos_name+'] during ['+function_names[fun]+']');
  151. {$i+}
  152.       dos_regs.ax := dos_error;     {return standard failure code}
  153.       dos_delay(3000);
  154.    end;
  155. end;
  156.  
  157.  
  158. (* -------------------------------------------------------- *)
  159. procedure dos_call(fun: dos_functions);
  160. begin
  161.    msdos(dos_regs);
  162.    dos_check_error(fun);
  163. end;
  164.  
  165.  
  166. (* -------------------------------------------------------- *)
  167. procedure prepare_dos_name(var name: dos_filename);
  168. begin
  169.    while (name <> '') and (name[length(name)] <= ' ') do
  170.       dec(name[0]);
  171.  
  172. {  if name = '' then
  173.       name := 'Nul'; }
  174.  
  175.    dos_name := name;
  176.    dos_name[length(dos_name)+1] := #0;
  177.    dos_regs.ds := seg(dos_name);
  178.    dos_regs.dx := ofs(dos_name)+1;
  179. end;
  180.  
  181.  
  182. (* -------------------------------------------------------- *)
  183. function dos_open(name:    dos_filename;
  184.                   mode:    open_modes):  dos_handle;
  185. var
  186.    try: integer;
  187.  
  188. begin
  189.  
  190. {$IFDEF DEBUGGING}
  191.    if debugging then
  192.       writeln(debugfd^,'dos_open(',name,',',ord(mode),')');
  193. {$ENDIF}
  194.  
  195.    dos_open := dos_error;
  196.    for try := 1 to dos_retry_count do
  197.    begin
  198.       dos_regs.ax := $3d00 + ord(mode);
  199.       if lo(DosVersion) >= 3 then
  200.          inc(dos_regs.ax,$40);
  201.  
  202.       prepare_dos_name(name);
  203.       if name = '' then
  204.          exit;
  205.  
  206.       msdos(dos_regs);
  207.  
  208.       {return to caller immediately if no errors were detected}
  209.       if (dos_regs.flags and Fcarry) = 0 then
  210.       begin
  211.          if (dos_regs.ax >= min_handle) and (dos_regs.ax <= max_handle) then
  212.             dos_names[dos_regs.ax] := name;
  213.  
  214.          dos_open := dos_regs.ax;
  215.          exit;
  216.       end;
  217.  
  218.       {return to caller if file-not-found}
  219.       if (dos_regs.ax = 2) then
  220.          exit;
  221.  
  222.       {report other errors and attempt to retry}
  223.       dos_check_error(_open);
  224.  
  225.       {return to caller if dir-not-found}
  226.       if (dos_regs.es = 3) then
  227.          exit;
  228.    end;
  229.  
  230. end;
  231.  
  232.  
  233. (* -------------------------------------------------------- *)
  234. function dos_create(name:    dos_filename): dos_handle;
  235. begin
  236.    dos_regs.ax := $3c00;
  237.    prepare_dos_name(name);
  238.    if name = '' then
  239.    begin
  240.       dos_create := dos_error;
  241.       exit;
  242.    end;
  243.  
  244. {$IFDEF DEBUGGING}
  245.    if debugging then
  246.       writeln(debugfd^,'dos_create(',name,')');
  247. {$ENDIF}
  248.  
  249.    dos_regs.cx := 0;   {attrib}
  250.    dos_call(_creat);
  251.    if (dos_regs.ax >= min_handle) and (dos_regs.ax <= max_handle) then
  252.       dos_names[dos_regs.ax] := name;
  253.    dos_create := dos_regs.ax;
  254. end;
  255.  
  256.  
  257. (* -------------------------------------------------------- *)
  258. function dos_read( handle:  dos_handle;
  259.                    var      buffer;
  260.                    bytes:   word): word;
  261. var
  262.    try:  integer;
  263.  
  264. begin
  265.    for try := 1 to dos_retry_count do
  266.    begin
  267.       dos_regs.ax := $3f00;
  268.       dos_regs.bx := handle;
  269.       dos_regs.cx := bytes;
  270.       dos_regs.ds := seg(buffer);
  271.       dos_regs.dx := ofs(buffer);
  272.       msdos(dos_regs);
  273.       dos_read := dos_regs.ax;
  274.  
  275.       {return to caller immediately if no errors were detected}
  276.       if (dos_regs.flags and Fcarry) = 0 then
  277.          exit;
  278.  
  279.       dos_read := dos_error;
  280.  
  281.       {report other errors and attempt to retry}
  282.       dos_check_error(_read);
  283.  
  284.       {return to caller if not access-denied}
  285.       if (dos_regs.es <> 5) then
  286.          exit;
  287.    end;
  288.  
  289. (************
  290.    dos_regs.ax := $3f00;
  291.    dos_regs.bx := handle;
  292.    dos_regs.cx := bytes;
  293.    dos_regs.ds := seg(buffer);
  294.    dos_regs.dx := ofs(buffer);
  295.    dos_call(_read);
  296.    dos_read := dos_regs.ax;
  297. ***********)
  298. end;
  299.  
  300.  
  301. (* -------------------------------------------------------- *)
  302. procedure dos_write(handle:  dos_handle;
  303.                     var      buffer;
  304.                     bytes:   word);
  305. begin
  306. {if bytes=0 then writeln('DOS: write 0 bytes!!');}
  307.  
  308.    dos_regs.ax := $4000;
  309.    dos_regs.bx := handle;
  310.    dos_regs.cx := bytes;
  311.    dos_regs.ds := seg(buffer);
  312.    dos_regs.dx := ofs(buffer);
  313.    dos_call(_write);
  314.    dos_regs.cx := bytes;
  315.    dos_write_err := dos_regs.ax <> dos_regs.cx;
  316. end;
  317.  
  318.  
  319. (* -------------------------------------------------------- *)
  320. procedure dos_lseek(handle:  dos_handle;
  321.                     offset:  longint;
  322.                     method:  seek_modes);
  323. var
  324.    pos:  long_integer absolute offset;
  325.  
  326. begin
  327.    dos_regs.ax := $4200 + ord(method);
  328.    dos_regs.bx := handle;
  329.    dos_regs.cx := pos.msw;
  330.    dos_regs.dx := pos.lsw;
  331.    dos_call(_lseek);
  332. end;
  333.  
  334.  
  335. (* -------------------------------------------------------- *)
  336. procedure dos_rseek(handle:  dos_handle;
  337.                     recnum:  word;
  338.                     recsiz:  word;
  339.                     method:  seek_modes);
  340. var
  341.    offset: longint;
  342.    pos:    long_integer absolute offset;
  343.  
  344. begin
  345.    offset := longint(recnum) * longint(recsiz);
  346.    dos_regs.ax := $4200 + ord(method);
  347.    dos_regs.bx := handle;
  348.    dos_regs.cx := pos.msw;
  349.    dos_regs.dx := pos.lsw;
  350.    dos_call(_rseek);
  351. end;
  352.  
  353.  
  354. (* -------------------------------------------------------- *)
  355. function dos_tell: longint;
  356.   {call immediately after dos_lseek or dos_rseek}
  357. var
  358.    pos:  long_integer;
  359.    li:   longint absolute pos;
  360. begin
  361.    pos.lsw := dos_regs.ax;
  362.    pos.msw := dos_regs.dx;
  363.    dos_tell := li;
  364. end;
  365.  
  366.  
  367. (* -------------------------------------------------------- *)
  368. procedure dos_find_eof(fd: dos_handle);
  369.    {find end of file, skip backward over ^Z eof markers}
  370. var
  371.    b: char;
  372.    n: word;
  373.    i: word;
  374.    p: longint;
  375.    temp: array[1..128] of char;
  376.  
  377. begin
  378.    dos_lseek(fd,0,seek_end);
  379.    p := dos_tell-1;
  380.    if p < 0 then
  381.       exit;
  382.  
  383.    p := p and $FFFF80;   {round to last 'sector'}
  384.    {search forward for the eof marker}
  385.    dos_lseek(fd,p,seek_start);
  386.    n := dos_read(fd,temp,sizeof(temp));
  387.    i := 1;
  388.  
  389.    while (i <= n) and (temp[i] <> ^Z) do
  390.    begin
  391.       inc(i);
  392.       inc(p);
  393.    end;
  394.  
  395.    {backup to overwrite the eof marker}
  396.    dos_lseek(fd,p,seek_start);
  397. end;
  398.  
  399.  
  400. (* -------------------------------------------------------- *)
  401. procedure dos_close(handle:  dos_handle);
  402. begin
  403. {$IFDEF DEBUGGING}
  404.    if debugging then
  405.       if (handle >= min_handle) and (handle <= max_handle) then
  406.          writeln(debugfd^,'dos_close(',dos_names[handle],')')
  407.       else
  408.          writeln(debugfd^,'dos_close(invalid #',handle,')');
  409. {$ENDIF}
  410.  
  411.    dos_regs.ax := $3e00;
  412.    dos_regs.bx := handle;
  413.    msdos(dos_regs);  {dos_call;}
  414. end;
  415.  
  416.  
  417. (* -------------------------------------------------------- *)
  418. procedure dos_unlink(name:    dos_filename);
  419.    {delete a file, no error message if file doesn't exist}
  420. begin
  421.    dos_regs.ax := $4100;
  422.    prepare_dos_name(name);
  423.    if name = '' then
  424.       exit;
  425.    msdos(dos_regs);
  426.  
  427. {$IFDEF DEBUGGING}
  428.    if (dos_regs.flags and Fcarry) = 0 then
  429.       if debugging then
  430.          writeln(debugfd^,'dos_unlink(',name,')');
  431. {$ENDIF}
  432. end;
  433.  
  434.  
  435. (* -------------------------------------------------------- *)
  436. procedure dos_file_times(fd:       dos_handle;
  437.                          func:     dos_time_functions;
  438.                          var time: word;
  439.                          var date: word);
  440. begin
  441.    dos_regs.ax := $5700 + ord(func);
  442.    dos_regs.bx := fd;
  443.    dos_regs.cx := time;
  444.    dos_regs.dx := date;
  445.    dos_call(_times);
  446.    time := dos_regs.cx;
  447.    date := dos_regs.dx;
  448. end;
  449.  
  450.  
  451. (* -------------------------------------------------------- *)
  452. function dos_jdate(time,date: word): longint;
  453. begin
  454.  
  455. (***
  456.      write(' d=',date:5,' t=',time:5,' ');
  457.      write('8',   (date shr 9) and 127:1); {year}
  458.      write('/',   (date shr 5) and  15:2); {month}
  459.      write('/',   (date      ) and  31:2); {day}
  460.      write(' ',   (time shr 11) and 31:2); {hour}
  461.      write(':',   (time shr  5) and 63:2); {minute}
  462.      write(':',   (time shl  1) and 63:2); {second}
  463.      writeln(' j=', (longint(date) shl 16) + longint(time));
  464.  ***)
  465.  
  466.    dos_jdate := (longint(date) shl 16) + longint(time);
  467. end;
  468.  
  469.  
  470. (* -------------------------------------------------------- *)
  471. function dos_exists(name: dos_filename): boolean;
  472. var
  473.    DirInfo:     SearchRec;
  474.  
  475. begin
  476.    dos_exists := false;
  477.    prepare_dos_name(name);
  478.    if name = '' then
  479.       exit;
  480.  
  481.    FindFirst(dos_name,AnyFile,DirInfo);
  482.  
  483. {$IFDEF DEBUGGING}
  484.    if debugging then
  485.       writeln(debugfd^,'dos_exists(',name,')? -> ',DosError=0);
  486. {$ENDIF}
  487.  
  488.    if DosError = 0 then
  489.       dos_exists := true;
  490. end;
  491.  
  492.  
  493. (* -------------------------------------------------------- *)
  494. function dos_lock(handle:  dos_handle;
  495.                   offset:  longint;
  496.                   bytes:   word): boolean;
  497. var
  498.    pos:    long_integer absolute offset;
  499.  
  500. begin
  501.    dos_regs.ax := $5c00;
  502.    dos_regs.bx := handle;
  503.    dos_regs.cx := pos.msw;
  504.    dos_regs.dx := pos.lsw;
  505.    dos_regs.si := 0;
  506.    dos_regs.di := bytes;
  507.    msdos(dos_regs);
  508.  
  509.    dos_lock := false;
  510.    if ((dos_regs.flags and Fcarry) = 0) or (dos_regs.ax = 1) then
  511.       dos_lock := true
  512.    else
  513.       case dos_regs.ax of
  514.          5,    {access denied}
  515.          32,   {sharing violation}
  516.          33:   {lock violation}
  517.             ;
  518.          else
  519.             dos_check_error(_lock);
  520.       end;
  521. end;
  522.  
  523.  
  524. (* -------------------------------------------------------- *)
  525. procedure dos_unlock(handle:  dos_handle;
  526.                      offset:  longint;
  527.                      bytes:   word);
  528. var
  529.    pos:    long_integer absolute offset;
  530.  
  531. begin
  532.    dos_regs.ax := $5c01;
  533.    dos_regs.bx := handle;
  534.    dos_regs.cx := pos.msw;
  535.    dos_regs.dx := pos.lsw;
  536.    dos_regs.si := 0;
  537.    dos_regs.di := bytes;
  538.    msdos(dos_regs);
  539.  
  540.    if (dos_regs.flags and Fcarry) <> 0 then
  541.    case dos_regs.ax of
  542.       1,    {invalid function}
  543.       5,    {access denied}
  544.       32,   {sharing violation}
  545.       33:   {lock violation}
  546.          ;
  547.       else
  548.          dos_check_error(_unlock);
  549.    end;
  550. end;
  551.  
  552.  
  553. (* -------------------------------------------------------- *)
  554. procedure dos_time(var ms: longint);
  555. var
  556.    reg:  registers;
  557. begin
  558.    reg.ax := 0;
  559.    intr($1a,reg);
  560.    ms := ((reg.cx shl 16) + reg.dx) * 55;
  561. end;
  562.  
  563.  
  564. (* -------------------------------------------------------- *)
  565. procedure dos_delay(ms: longint);
  566. var
  567.    time,start:  longint;
  568. begin
  569.    dos_time(start);
  570.    repeat
  571.       dos_time(time);
  572.    until (time > (start+ms)) or (time < start);
  573. end;
  574.  
  575.  
  576. (* -------------------------------------------------------- *)
  577. begin
  578.    val(GetEnv('RETRY_COUNT'),dos_retry_count,dos_regs.ax);
  579.    if dos_retry_count = 0 then
  580.       dos_retry_count := 5;
  581. end.
  582.  
  583.